home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / fpkpas92.zip / SRCRTL.ZIP / RTL / DOS / DOS.PP < prev    next >
Text File  |  1997-07-01  |  26KB  |  966 lines
  1. {****************************************************************************
  2.  
  3.                           FPKPascal Runtime-Library
  4.                           Copyright (c) 1994,97 by
  5.                     Florian Klaempfl and Michael Spiegel
  6.  
  7.  ****************************************************************************}
  8. {$ifdef DOS}
  9. {$define GO32V1}
  10. {$endif}
  11.  
  12. {
  13.   History:
  14.   2.7.1994: Version 0.2
  15.             Datenstrukturen sind deklariert sowie
  16.             50 % der Unterprogramme sind implementiert
  17.   12.8.1994: exec implemented
  18.   14.8.1994: findfirst and findnext implemented
  19.   24.8.1994: Version 0.3
  20.   28.2.1995: Version 0.31
  21.              some parameter lists with const optimized
  22.    3.7.1996: bug in fsplit removed (dir and ext were not intializised)
  23.    7.7.1996: packtime and unpacktime implemented
  24.   20.9.1996: Version 0.5
  25.              setftime and getftime implemented
  26.              some optimizations done (integer -> longint)
  27.              procedure fsearch from the LINUX version ported
  28.              msdos call implemented
  29.   26th november 1996:
  30.              better fexpand
  31.   29th january 1997:
  32.              bug in getftime and setftime removed
  33.              setfattr and getfattr added
  34.    2th february 1997: Version 0.9
  35.              bug of searchrec corrected
  36.   30th may 1997:
  37.              bug in fsplit fixed (thanks to Pierre Muller):
  38.                If you have a relative path as argument
  39.                fsplit gives a wrong result because it
  40.                first tries to find the extension by searching the first
  41.                occurence of '.'.
  42.  
  43.                The file extension should be tested last !!
  44.   15th june 1997:
  45.              versions for go32v1 and go32v2 merged
  46. }
  47.  
  48. unit dos;
  49.  
  50.   interface
  51.  
  52.     uses
  53.        strings
  54. {$ifdef GO32V2}
  55.        ,go32
  56. {$endif GO32V2}
  57.        ;
  58.  
  59.     const
  60.        { bit masks for CPU flags}
  61.        fcarry = $0001;
  62.        fparity = $0004;
  63.        fauxiliary = $0010;
  64.        fzero = $0040;
  65.        fsign = $0080;
  66.        foverflow  = $0800;
  67.  
  68.        { bit masks for file attributes }
  69.        readonly = $01;
  70.        hidden = $02;
  71.        sysfile = $04;
  72.        volumeid = $08;
  73.        directory = $10;
  74.        archive = $20;
  75.        anyfile = $3F;
  76.        fmclosed = $D7B0;
  77.        fminput = $D7B1;
  78.        fmoutput = $D7B2;
  79.        fminout = $D7B3;
  80.  
  81.     type
  82.        { some string types }
  83.        comstr = string[127];        { command line string }
  84.        pathstr = string[79];        { string for a file path }
  85.        dirstr = string[67];         { string for a directory }
  86.        namestr = string[8];         { string for a file name }
  87.        extstr = string[4];          { string for an extension }
  88.  
  89.        { search record which is used by findfirst and findnext }
  90. {$PACKRECORDS 1}
  91.        searchrec = record
  92.           fill : array[1..21] of byte;
  93.           attr : byte;
  94.           time : longint;
  95.           reserved : word; { requires the DOS extender (DJ GNU-C) }
  96.           size : longint;
  97.           name : string[15]; { the same size as declared by (DJ GNU C) }
  98.        end;
  99. {$PACKRECORDS 2}
  100.  
  101.        { file record for untyped files }
  102.        filerec = record
  103.           handle : word;
  104.           mode : word;
  105.           recsize : word;
  106.           _private : array[1..26] of byte;
  107.           userdata: array[1..16] of byte;
  108.           name: array[0..79] of char;
  109.        end;
  110.  
  111.        { file record for text files }
  112.        textbuf = array[0..127] of char;
  113.  
  114.        textrec = record
  115.           handle : word;
  116.           mode : word;
  117.           bufSize : word;
  118.           _private : word;
  119.           bufpos : word;
  120.           bufend : word;
  121.           bufptr : ^textbuf;
  122.           openfunc : pointer;
  123.           inoutfunc : pointer;
  124.           flushfunc : pointer;
  125.           closefunc : pointer;
  126.           userdata : array[1..16] of byte;
  127.           name : array[0..79] of char;
  128.           buffer : textbuf;
  129.        end;
  130.  
  131. {$ifdef GO32V1}
  132.        { data structure for the registers needed by msdos and intr }
  133.        { Go32 V2 follows trealregs of go32 }
  134.  
  135.        registers = record
  136.          case i : integer of
  137.             0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
  138.             1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
  139.             2 : (eax,  ebx,  ecx,  edx,  ebp,  esi,  edi : longint);
  140.        end;
  141. {$endif GO32V1}
  142.  
  143. {$PACKRECORDS 1}
  144.        { record for date and time }
  145.        datetime = record
  146.           year,month,day,hour,min,sec : word;
  147.        end;
  148.  
  149.     var
  150.        { error variable }
  151.        doserror : integer;
  152.  
  153.     procedure getdate(var year,month,day,dayofweek : word);
  154.     procedure gettime(var hour,minute,second,sec100 : word);
  155.     function dosversion : word;
  156.     procedure setdate(year,month,day : word);
  157.     procedure settime(hour,minute,second,sec100 : word);
  158.     procedure getcbreak(var breakvalue : boolean);
  159.     procedure setcbreak(breakvalue : boolean);
  160.     procedure getverify(var verify : boolean);
  161.     procedure setverify(verify : boolean);
  162.     function diskfree(drive : byte) : longint;
  163.     function disksize(drive : byte) : longint;
  164.     procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  165.     procedure findnext(var f : searchRec);
  166.  
  167.     { is a dummy }
  168.     procedure swapvectors;
  169.  
  170. {   not supported:
  171.     procedure getintvec(intno : byte;var vector : pointer);
  172.     procedure setintvec(intno : byte;vector : pointer);
  173.     procedure keep(exitcode : word);
  174. }
  175.     procedure msdos(var regs : registers);
  176.     procedure intr(intno : byte;var regs : registers);
  177.  
  178.     procedure getfattr(var f;var attr : word);
  179.     procedure setfattr(var f;attr : word);
  180.  
  181.     function fsearch(const path : pathstr;dirlist : string) : pathstr;
  182.     procedure getftime(var f;var time : longint);
  183.     procedure setftime(var f;time : longint);
  184.     procedure packtime (var d: datetime; var time: longint);
  185.     procedure unpacktime (time: longint; var d: datetime);
  186.     function fexpand(const path : pathstr) : pathstr;
  187.     procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
  188.       var ext : extstr);
  189.     procedure exec(const path : pathstr;const comline : comstr);
  190.     function dosexitcode : word;
  191.     function envcount : longint;
  192.     function envstr(index : longint) : string;
  193.     function getenv(const envvar : string): string;
  194.  
  195.   implementation
  196.  
  197.     var
  198.        dosregs : registers;
  199.  
  200.     { this was first written for the LINUX version,    }
  201.     { by Michael Van Canneyt but it works also         }
  202.     { for the DOS version (I hope so)                  }
  203.     function fsearch(const path : pathstr;dirlist : string) : pathstr;
  204.  
  205.       var
  206.          newdir : pathstr;
  207.          p1 : byte;
  208.          s : searchrec;
  209.  
  210.       begin
  211.          if (pos('?',path)<>0) or (pos('*',path)<>0) then
  212.            { No wildcards allowed in these things }
  213.            fsearch:=''
  214.          else
  215.            begin
  216.               repeat
  217.                 { get first path }
  218.                 p1:=pos(';',dirlist);
  219.                 if p1>0 then
  220.                   begin
  221.                      newdir:=copy(dirlist,1,p1-1);
  222.                      delete(dirlist,1,p1)
  223.                   end
  224.                 else
  225.                   begin
  226.                      newdir:=dirlist;
  227.                      dirlist:=''
  228.                   end;
  229.                 findfirst(newdir+'\'+path,anyfile,s);
  230.                 if doserror=0 then
  231.                   begin
  232.                      newdir:=newdir+'\'+s.name;
  233.                      { this was for LINUX:
  234.                      if pos('.\',newdir)=1 then
  235.                        delete(newdir, 1, 2)
  236.                      { DOS strips off an initial .\ }
  237.                      }
  238.                   end
  239.                 else newdir:='';
  240.               until(dirlist='') or (length(newdir)>0);
  241.               fsearch:=newdir;
  242.            end;
  243.       end;
  244.  
  245.     procedure getftime(var f;var time : longint);
  246.  
  247.       begin
  248.          dosregs.bx:=textrec(f).handle;
  249.          dosregs.ax:=$5700;
  250.          msdos(dosregs);
  251.          time:=(dosregs.dx shl 16)+dosregs.cx;
  252.          doserror:=dosregs.al;
  253.       end;
  254.  
  255.    procedure setftime(var f;time : longint);
  256.  
  257.       begin
  258.          dosregs.bx:=textrec(f).handle;
  259.          dosregs.ecx:=time;
  260.          dosregs.ax:=$5701;
  261.          msdos(dosregs);
  262.          doserror:=dosregs.al;
  263.       end;
  264.  
  265.     procedure msdos(var regs : registers);
  266.  
  267.       begin
  268.          intr($21,regs);
  269.       end;
  270. {$ifdef GO32V2}
  271.     procedure intr(intno : byte;var regs : registers);
  272.  
  273.       begin
  274.          realintr(intno,regs);
  275.       end;
  276. {$else GO32V2}
  277.     procedure intr(intno : byte;var regs : registers);
  278.  
  279.       begin
  280.          asm
  281.             .data
  282.     int86:
  283.             .byte        0xcd
  284.     int86_vec:
  285.             .byte        0x03
  286.             jmp        int86_retjmp
  287.  
  288.             .text
  289.             movl        8(%ebp),%eax
  290.             movb        %al,int86_vec
  291.  
  292.             movl        10(%ebp),%eax
  293.             // do not use first int
  294.             addl        $2,%eax
  295.  
  296.             movl        4(%eax),%ebx
  297.             movl        8(%eax),%ecx
  298.             movl        12(%eax),%edx
  299.             movl        16(%eax),%ebp
  300.             movl        20(%eax),%esi
  301.             movl        24(%eax),%edi
  302.             movl        (%eax),%eax
  303.  
  304.             jmp        int86
  305.     int86_retjmp:
  306.             pushf
  307.             pushl    %ebp
  308.             pushl       %eax
  309.             movl        %esp,%ebp
  310.             // calc EBP new
  311.             addl        $12,%ebp
  312.             movl        10(%ebp),%eax
  313.             // do not use first int
  314.             addl        $2,%eax
  315.  
  316.             popl        (%eax)
  317.             movl        %ebx,4(%eax)
  318.             movl        %ecx,8(%eax)
  319.             movl        %edx,12(%eax)
  320.             // restore EBP
  321.             popl    %edx
  322.             movl    %edx,16(%eax)
  323.             movl        %esi,20(%eax)
  324.             movl        %edi,24(%eax)
  325.             // ignore ES and DS
  326.             popl        %ebx        /* flags */
  327.             movl        %ebx,32(%eax)
  328.             // FS and GS too
  329.          end;
  330.       end;
  331. {$endif GO32V2}
  332.     var
  333.        lastdosexitcode : word;
  334. {$ifdef GO32V2}
  335.     procedure exec(const path : pathstr;const comline : comstr);
  336.  
  337.       procedure do_system(p,c : pchar);
  338.  
  339.       {
  340.         Table 0931
  341.         Format of EXEC parameter block for AL=00h,01h,04h:
  342.         Offset    Size    Description
  343.          00h    WORD    segment of environment to copy for child process (copy caller's
  344.                   environment if 0000h)
  345.          02h    DWORD    pointer to command tail to be copied into child's PSP
  346.          06h    DWORD    pointer to first FCB to be copied into child's PSP
  347.          0Ah    DWORD    pointer to second FCB to be copied into child's PSP
  348.          0Eh    DWORD    (AL=01h) will hold subprogram's initial SS:SP on return
  349.          12h    DWORD    (AL=01h) will hold entry point (CS:IP) on return
  350.         INT 21 4B--
  351.  
  352.         Copied from Ralf Brown's Interrupt List
  353.       }
  354.  
  355.       type
  356.          realptr = record
  357.         ofs,seg : word;
  358.        end;
  359.  
  360.          texecblock = record
  361.         envseg : word;
  362.         comtail : realptr;
  363.         firstFCB : realptr;
  364.         secondFCB : realptr;
  365.         iniStack : realptr;
  366.         iniCSIP : realptr;
  367.       end;
  368.  
  369.       var
  370.          la_c,la_e : longint;
  371.      execblock : texecblock;
  372.  
  373.       begin
  374.          copytodos(p^,strlen(p)+1);
  375.          la_c:=transfer_buffer+strlen(p)+1;
  376.          seg_move(get_ds,longint(c),dosmemselector,la_c,strlen(c)+1);
  377.      la_e:=la_c+strlen(c)+1;
  378.      with execblock do
  379.        begin
  380.           envseg:=0;
  381.           comtail.seg:=la_c div 16;
  382.           comtail.ofs:=la_c mod 16;
  383.           firstFCB.seg:=0;
  384.           firstFCB.ofs:=0;
  385.           secondFCB.seg:=0;
  386.           secondFCB.ofs:=0;
  387.        end;
  388.       seg_move(get_ds,longint(@execblock),dosmemselector,la_e,sizeof(texecblock));
  389.          dosregs.edx:=transfer_buffer mod 16;
  390.          dosregs.ds:=transfer_buffer div 16;
  391.          dosregs.ebx:=la_e mod 16;
  392.          dosregs.es:=la_e div 16;
  393.          dosregs.ax:=$4b00;
  394.          msdos(dosregs);
  395.          if (dosregs.flags and 1) <> 0 then
  396.            begin
  397.               doserror:=dosregs.ax;
  398.              lastdosexitcode:=0;
  399.               exit;
  400.            end
  401.          else
  402.        begin
  403.               dosregs.ax:=$4d00;
  404.               msdos(dosregs);
  405.               lastdosexitcode:=dosregs.al;
  406.        end;
  407.         end;
  408.  
  409.       var
  410.          p,c : array[0..255] of char;
  411.  
  412.       begin
  413.          move(path[1],p,length(path));
  414.          p[length(path)]:=#0;
  415.          move(comline[1],c,length(comline));
  416.          c[length(comline)]:=#13;
  417.          c[length(comline)+1]:=#0;
  418.          do_system(p,c);
  419.       end;
  420.  
  421. {$else GO32V2}
  422.  
  423.     procedure exec(const path : pathstr;const comline : comstr);
  424.  
  425.       procedure do_system(p : pchar);
  426.  
  427.         begin
  428.            asm
  429.               movl 12(%ebp),%ebx
  430.               movw $0xff07,%ax
  431.               int $0x21
  432.               movw %ax,_LASTDOSEXITCODE
  433.            end;
  434.         end;
  435.  
  436.       var
  437.          execute : string;
  438.          b : array[0..255] of char;
  439.  
  440.       begin
  441.          execute:=path+' '+comline;
  442.          move(execute[1],b,length(execute));
  443.          b[length(execute)]:=#0;
  444.          do_system(b);
  445.       end;
  446.  
  447. {$endif GO32V2}
  448.  
  449.     function dosexitcode : word;
  450.  
  451.       begin
  452.          dosexitcode:=lastdosexitcode;
  453.       end;
  454.  
  455.     function dosversion : word;
  456.  
  457.       begin
  458.          dosregs.ax:=$3000;
  459.          msdos(dosregs);
  460.          dosversion:=dosregs.ax;
  461.       end;
  462.  
  463.     procedure getdate(var year,month,day,dayofweek : word);
  464.  
  465.       begin
  466.          dosregs.ax:=$2a00;
  467.          msdos(dosregs);
  468.          dayofweek:=dosregs.al;
  469.          year:=dosregs.cx;
  470.          month:=dosregs.dh;
  471.          day:=dosregs.dl;
  472.       end;
  473.  
  474.     procedure setdate(year,month,day : word);
  475.  
  476.       begin
  477.          dosregs.cx:=year;
  478.          dosregs.dx:=month*$100+day;
  479.          dosregs.ah:=$2b;
  480.          msdos(dosregs);
  481.          doserror:=dosregs.al;
  482.       end;
  483.  
  484.     procedure gettime(var hour,minute,second,sec100 : word);
  485.  
  486.       begin
  487.          dosregs.ah:=$2c;
  488.          msdos(dosregs);
  489.          hour:=dosregs.ch;
  490.          minute:=dosregs.cl;
  491.          second:=dosregs.dh;
  492.          sec100:=dosregs.dl;
  493.       end;
  494.  
  495.     procedure settime(hour,minute,second,sec100 : word);
  496.  
  497.       begin
  498.          dosregs.cx:=hour*$100+minute;
  499.          dosregs.dx:=second*$100+sec100;
  500.          dosregs.ah:=$2d;
  501.          msdos(dosregs);
  502.          doserror:=dosregs.al;
  503.       end;
  504.  
  505.     procedure getcbreak(var breakvalue : boolean);
  506.  
  507.       begin
  508.          dosregs.ax:=$3300;
  509.          msdos(dosregs);
  510.          breakvalue:=dosregs.dl<>0;
  511.       end;
  512.  
  513.     procedure setcbreak(breakvalue : boolean);
  514.  
  515.       begin
  516.          dosregs.ax:=$3301;
  517.          dosregs.dl:=ord(breakvalue);
  518.          msdos(dosregs);
  519.       end;
  520.  
  521.     procedure getverify(var verify : boolean);
  522.  
  523.       begin
  524.          dosregs.ah:=$54;
  525.          msdos(dosregs);
  526.          verify:=dosregs.al<>0;
  527.       end;
  528.  
  529.     procedure setverify(verify : boolean);
  530.  
  531.       begin
  532.          dosregs.ah:=$2e;
  533.          dosregs.al:=ord(verify);
  534.          msdos(dosregs);
  535.       end;
  536.  
  537.     function diskfree(drive : byte) : longint;
  538.  
  539.       begin
  540.          dosregs.dl:=drive;
  541.          dosregs.ah:=$36;
  542.          msdos(dosregs);
  543.          if dosregs.ax<>$FFFF then
  544.            begin
  545.               diskfree:=dosregs.ax;
  546.               diskfree:=diskfree*dosregs.bx;
  547.               diskfree:=diskfree*dosregs.cx;
  548.            end
  549.          else
  550.            diskfree:=-1;
  551.       end;
  552.  
  553.     function disksize(drive : byte) : longint;
  554.  
  555.       begin
  556.          dosregs.dl:=drive;
  557.          dosregs.ah:=$36;
  558.          msdos(dosregs);
  559.          if dosregs.ax<>$FFFF then
  560.            begin
  561.               disksize:=dosregs.ax;
  562.               disksize:=disksize*dosregs.bx;
  563.               disksize:=disksize*dosregs.dx;
  564.            end
  565.          else
  566.            disksize:=-1;
  567.       end;
  568.  
  569.     procedure searchrec2dossearchrec(var f : searchrec);
  570.  
  571.       var
  572.          l,i : longint;
  573.  
  574.       begin
  575.          l:=length(f.name);
  576.          for i:=1 to 12 do
  577.            f.name[i-1]:=f.name[i];
  578.          f.name[l]:=#0;
  579.       end;
  580.  
  581.     procedure dossearchrec2searchrec(var f : searchrec);
  582.  
  583.       var
  584.          l,i : longint;
  585.  
  586.       begin
  587.          for i:=0 to 12 do
  588.            if f.name[i]=#0 then
  589.              begin
  590.                 l:=i;
  591.                 break;
  592.              end;
  593.          for i:=11 downto 0 do
  594.            f.name[i+1]:=f.name[i];
  595.          f.name[0]:=chr(l);
  596.       end;
  597.  
  598.     procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  599.  
  600. {$ifdef GO32V2}
  601.  
  602.       procedure _findfirst(path : pchar;attr : word;var f : searchrec);
  603.  
  604.         begin
  605.            copytodos(f,sizeof(searchrec));
  606.            dosregs.edx:=transfer_buffer mod 16;
  607.            dosregs.ds:=transfer_buffer div 16;
  608.        dosregs.ah:=$1a;
  609.            msdos(dosregs);
  610.            dosregs.ecx:=attr;
  611.            dosregs.edx:=(transfer_buffer mod 16) + Sizeof(searchrec)+1;
  612.            dosmemput(transfer_buffer div 16,
  613.              (transfer_buffer mod 16) +Sizeof(searchrec)+1,path^,strlen(path)+1);
  614.            dosregs.ds:=transfer_buffer div 16;
  615.        dosregs.ah:=$4e;
  616.            msdos(dosregs);
  617.            copyfromdos(f,sizeof(searchrec));
  618.            if dosregs.flags and carryflag<>0 then
  619.              doserror:=dosregs.ax;
  620.         end;
  621.  
  622. {$else GO32V2}
  623.  
  624.       procedure _findfirst(path : pchar;attr : word;var f : searchrec);
  625.  
  626.         begin
  627.            asm
  628.               movl 18(%ebp),%edx
  629.               movb $0x1a,%ah
  630.               int $0x21
  631.               movl 12(%esp),%edx
  632.               movzwl 16(%esp),%ecx
  633.               movb $0x4e,%ah
  634.               int $0x21
  635.               jnc LFF
  636.               movw %ax,U_DOS_DOSERROR
  637.            LFF:
  638.            end;
  639.         end;
  640.  
  641. {$endif GO32V2}
  642.  
  643.       var
  644.          path0 : array[0..80] of char;
  645.  
  646.       begin
  647.          { no error }
  648.          doserror:=0;
  649.          strpcopy(path0,path);
  650.          _findfirst(path0,attr,f);
  651.          dossearchrec2searchrec(f);
  652.       end;
  653.  
  654.     procedure findnext(var f : searchRec);
  655.  
  656. {$ifdef GO32V2}
  657.  
  658.       procedure _findnext(var f : searchrec);
  659.  
  660.         begin
  661.            copytodos(f,sizeof(searchrec));
  662.            dosregs.edx:=transfer_buffer mod 16;
  663.            dosregs.ds:=transfer_buffer div 16;
  664.        dosregs.ah:=$1a;
  665.            msdos(dosregs);
  666.        dosregs.ah:=$4f;
  667.            msdos(dosregs);
  668.            copyfromdos(f,sizeof(searchrec));
  669.            if dosregs.flags and carryflag <> 0 then
  670.              doserror:=dosregs.ax;
  671.         end;
  672.  
  673. {$else GO32V2}
  674.  
  675.       procedure _findnext(var f : searchrec);
  676.  
  677.         begin
  678.            asm
  679.               movl 12(%ebp),%edx
  680.               movb $0x1a,%ah
  681.               int $0x21
  682.               movb $0x4f,%ah
  683.               int $0x21
  684.               jnc LFN
  685.               movw %ax,U_DOS_DOSERROR
  686.            LFN:
  687.            end;
  688.         end;
  689.  
  690. {$endif GO32V2}
  691.  
  692.       begin
  693.          { no error }
  694.          doserror:=0;
  695.          searchrec2dossearchrec(f);
  696.          _findnext(f);
  697.          dossearchrec2searchrec(f);
  698.       end;
  699.  
  700.     procedure swapvectors;
  701.  
  702.       begin
  703.          { only a dummy }
  704.       end;
  705.  
  706.     type
  707.        ppchar = ^pchar;
  708.  
  709. {$ifdef GO32V1}
  710.  
  711.     function envs : ppchar;
  712.  
  713.       begin
  714.          asm
  715.             movl _environ,%eax
  716.             leave
  717.             ret
  718.          end ['EAX'];
  719.       end;
  720.  
  721. {$endif}
  722.  
  723.     function envcount : longint;
  724.  
  725.       var
  726.          hp : ppchar;
  727.  
  728.       begin
  729. {$ifdef GO32V2}
  730.          hp:=environ;
  731. {$else GO32V2}
  732.          hp:=envs;
  733. {$endif}
  734.          envcount:=0;
  735.          while assigned(hp^) do
  736.            begin
  737.               { not the best solution, but quite understandable }
  738.               inc(envcount);
  739.               hp:=hp+4;
  740.            end;
  741.       end;
  742.  
  743.     function envstr(index : longint) : string;
  744.  
  745.       var
  746.          hp : ppchar;
  747.  
  748.       begin
  749.          if (index<=0) or (index>envcount) then
  750.            begin
  751.               envstr:='';
  752.               exit;
  753.            end;
  754. {$ifdef GO32V2}
  755.          hp:=environ+4*(index-1);
  756. {$else GO32V2}
  757.          hp:=envs+4*(index-1);
  758. {$endif GO32V2}
  759.          envstr:=strpas(hp^);
  760.       end;
  761.  
  762.     function getenv(const envvar : string) : string;
  763.  
  764.       var
  765.          hs,_envvar : string;
  766.          eqpos,i : longint;
  767.  
  768.       begin
  769.          _envvar:=upcase(envvar);
  770.          getenv:='';
  771.          for i:=1 to envcount do
  772.            begin
  773.               hs:=envstr(i);
  774.               eqpos:=pos('=',hs);
  775.               if copy(hs,1,eqpos-1)=_envvar then
  776.                 begin
  777.                    getenv:=copy(hs,eqpos+1,length(hs)-eqpos);
  778.                    exit;
  779.                 end;
  780.            end;
  781.       end;
  782.  
  783.     procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
  784.       var ext : extstr);
  785.  
  786.       var
  787.          p1 : byte;
  788.  
  789.       begin
  790.          { get drive name }
  791.          p1:=pos(':',path);
  792.          if p1>0 then
  793.            begin
  794.               dir:=path[1]+':';
  795.               delete(path,1,p1);
  796.            end
  797.          else
  798.            dir:='';
  799.          { split the path and the name, there are no more path informtions }
  800.          { if path contains no backslashes                                 }
  801.          while true do
  802.            begin
  803.               p1:=pos('\',path);
  804.               if p1=0 then
  805.                 break;
  806.               dir:=dir+copy(path,1,p1);
  807.               delete(path,1,p1);
  808.            end;
  809.          { try to find out a extension }
  810.          p1:=pos('.',path);
  811.          if p1>0 then
  812.            begin
  813.               ext:=copy(path,p1,4);
  814.               delete(path,p1,length(path)-p1+1);
  815.            end
  816.          else
  817.            ext:='';
  818.          name:=path;
  819.       end;
  820.  
  821.     function fexpand(const path : pathstr) : pathstr;
  822.  
  823.       function get_current_drive : byte;
  824.       
  825.         var
  826.            r : registers;
  827.            
  828.         begin
  829.            r.ah:=$19;
  830.            msdos(r);
  831.            get_current_drive:=r.al;
  832.         end;           
  833.  
  834.        var
  835.           s,pa : string[79];
  836.  
  837.        begin
  838.           { There are differences between FPKPascal and Turbo Pascal
  839.             e.g. for the string 'D:\DEMO\..\HELLO' which isn't handled }
  840.           getdir(0,s);
  841.           pa:=upcase(path);
  842.           if (ord(pa[0])>1) and (((pa[1]>='A') and (pa[1]<='Z')) and (pa[2]=':')) then
  843.             begin
  844.                if (ord(pa[0])>2) and (pa[3]<>'\') then
  845.                  if pa[1]=s[1] then
  846.                    pa:=s+'\'+copy (pa,3,length(pa))
  847.                  else
  848.                    pa:=pa[1]+':\'+copy (pa,3,length(pa))
  849.             end
  850.           else
  851.             if pa[1]='\' then 
  852.               pa:=s[1]+':'+pa
  853.             else if s[0]=#3 then
  854.               pa:=s+pa
  855.             else
  856.               pa:=s+'\'+pa;
  857.           fexpand:=pa;
  858.        end;
  859.  
  860.      procedure packtime(var d : datetime;var time : longint);
  861.  
  862.        var
  863.           zs : longint;
  864.  
  865.        begin
  866.           time:=-1980;
  867.           time:=time+d.year and 127;
  868.           time:=time shl 4;
  869.           time:=time+d.month;
  870.           time:=time shl 5;
  871.           time:=time+d.day;
  872.           time:=time shl 16;
  873.           zs:=d.hour;
  874.           zs:=zs shl 6;
  875.           zs:=zs+d.min;
  876.           zs:=zs shl 5;
  877.           zs:=zs+d.sec div 2;
  878.           time:=time+(zs and $ffff);
  879.        end;
  880.  
  881.      procedure unpacktime (time: longint; var d: datetime);
  882.  
  883.        begin
  884.           d.sec:=(time and 31) * 2;
  885.           time:=time shr 5;
  886.           d.min:=time and 63;
  887.           time:=time shr 6;
  888.           d.hour:=time and 31;
  889.           time:=time shr 5;
  890.           d.day:=time and 31;
  891.           time:=time shr 5;
  892.           d.month:=time and 15;
  893.           time:=time shr 4;
  894.           d.year:=time + 1980;
  895.        end;
  896.  
  897. {$ifdef GO32V2}
  898.  
  899.     procedure getfattr(var f;var attr : word);
  900.  
  901.       var
  902.          r : registers;
  903.  
  904.       begin
  905.          copytodos(filerec(f).name,strlen(filerec(f).name)+1);
  906.          r.ax:=$4300;
  907.          r.edx:=transfer_buffer mod 16;
  908.          r.ds:=transfer_buffer div 16;
  909.          msdos(r);
  910.          if (r.flags and carryflag) <> 0 then
  911.            doserror:=r.ax;
  912.          attr:=r.cx;
  913.       end;
  914.  
  915.     procedure setfattr(var f;attr : word);
  916.  
  917.       var
  918.          r : registers;
  919.  
  920.       begin
  921.          copytodos(filerec(f).name,strlen(filerec(f).name)+1);
  922.          r.ax:=$4301;
  923.          r.edx:=transfer_buffer mod 16;
  924.          r.ds:=transfer_buffer div 16;
  925.          r.cx:=attr;
  926.          msdos(r);
  927.          if (r.flags and carryflag) <> 0 then
  928.            doserror:=r.ax;
  929.       end;
  930.  
  931. {$else GO32V2}
  932.  
  933.     procedure getfattr(var f;var attr : word);
  934.  
  935.       var
  936.          { to avoid problems }
  937.          n : array[0..255] of char;
  938.          r : registers;
  939.  
  940.       begin
  941.          strpcopy(n,filerec(f).name);
  942.          r.ax:=$4300;
  943.          r.edx:=longint(@n);
  944.          msdos(r);
  945.          attr:=r.cx;
  946.       end;
  947.  
  948.     procedure setfattr(var f;attr : word);
  949.  
  950.       var
  951.          { to avoid problems }
  952.          n : array[0..255] of char;
  953.          r : registers;
  954.  
  955.       begin
  956.          strpcopy(n,filerec(f).name);
  957.          r.ax:=$4301;
  958.          r.edx:=longint(@n);
  959.          r.cx:=attr;
  960.          msdos(r);
  961.       end;
  962.  
  963. {$endif GO32V2}
  964.  
  965. end.
  966.